home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / tclMode.tcl < prev   
Encoding:
Text File  |  1998-12-20  |  32.7 KB  |  1,049 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "tclMode.tcl"
  6.  #                                    created: 5/4/97 {9:31:10 pm} 
  7.  #                                last update: 20/12/1998 {11:27:15 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998 Vince Darley
  15.  #  
  16.  #    Three procs from original: Tcl::DblClick listArray, getVarValue
  17.  #    
  18.  #    Adds support for Tk, Itcl keywords and completions, plus 
  19.  #    numerous fixes, improvements and integration with Vince's
  20.  #    Additions.
  21.  # ###################################################################
  22.  ##
  23.  
  24. alpha::mode Tcl 1.7.1 tclMenu {*.tcl *.itcl *.itk} {
  25.     tclMenu electricTab electricReturn electricBraces
  26. } {
  27.     addMenu tclMenu "•269" "Tcl"
  28.     set unixMode(wish) {Tcl}
  29.     set unixMode(tclsh) {Tcl}
  30.     ensureset tclshSig "WIsH"
  31.     ensureset evaluateRemotely 0
  32.     trace variable evaluateRemotely w evaluateRemoteSynchronise
  33. } maintainer {
  34.     "Vince Darley" darley@fas.harvard.edu <http://www.fas.harvard.edu/~darley/>
  35. } uninstall this-file help {
  36.     This mode is for editing Tcl code.  You can edit code for internal
  37.     use with Alpha, or use Alpha as an external editor for code destined
  38.     for use with Tcl and Tk interpreters --- Sun distributes the Wish
  39.     application and a tcl-tk browser plugin.
  40.     
  41.     You can 'evaluate' a procedure (or any Tcl code for that matter) to 
  42.     make changes on the fly.  If you select 'Evaluate Remotely' in the 
  43.     tcl-tk submenu, then such actions will actually send the code
  44.     to a separately running Wish application to be evaluated.
  45. }
  46.  
  47.  
  48. proc tclMenu {} {}
  49.  
  50. # ◊◊◊◊ menu and prefs ◊◊◊◊ #
  51. # The menu.
  52. proc menu::buildtclMenu {} {
  53.     global tclMenu evaluateRemotely
  54.     set ma [list \
  55.       "/-<UswitchToTclsh" \
  56.       [list Menu -n "tcl-tk" -p tcltk::menuProc [list \
  57.       "![lindex {{ } •} $evaluateRemotely]evaluateRemotely" \
  58.       executeCommand]] \
  59.       "(-" "/L<O<BreloadProc" "/I<O<BreformatProc" \
  60.       "/Z<O<BtraceThisProc" "/Z<O<UtraceTclProc…" \
  61.       "/D<O<UdumpTraces" "(-" "rebuildTclIndices" "(-" \
  62.       "<U/PfindProcDefinition…" "/Q<IquickFindProc…" "getVarValue…" \
  63.       "insertMenuCodes…" "insertBindingCodes…" "/4<BaddRemoveDollars" \
  64.       "/3<BinsertDivider" "/8<I<BsurroundWithBullets"]
  65.     return [list build $ma Tcl::MenuProc "" $tclMenu]
  66. }
  67. menu::buildProc tclMenu menu::buildtclMenu
  68. menu::buildSome tclMenu
  69.  
  70. newPref v prefixString {# } Tcl
  71. newPref f wordWrap {0} Tcl
  72. newPref v funcExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  73. newPref v parseExpr {^proc *([+-a-zA-Z0-9]+)} Tcl
  74. newPref v wordBreak {(\$)?[\w:_]+} Tcl
  75. newPref v wordBreakPreface {([^\w:_\$]|.\$)} Tcl
  76. newPref f autoMark 0 Tcl
  77. newPref v stringColor green Tcl
  78. newPref v commentColor red Tcl
  79. newPref v keywordColor blue Tcl
  80. # Colour to use for Alpha's built in commands
  81. newPref v alphaKeyWordColor    none Tcl stringColorProc
  82. # Colour Tk commands
  83. newPref f recogniseTk 1 Tcl Tcl::_updateKeywords
  84. # Colour [incr Tcl] commands
  85. newPref f recogniseItcl 1 Tcl Tcl::_updateKeywords
  86. # Recognise and colour some common procedures 'lunion' etc.
  87. newPref f recognisePseudoTcl 1 Tcl Tcl::_updateKeywords
  88. # Indentation scheme for lines following one ending in a backslash
  89. newPref v indentSlashEndLines 1 Tcl "" indent::amounts varindex
  90. # Mark files structurally, recognising the special comments
  91. # entered by 'ctrl-3'
  92. newPref f structuralMarks 0 Tcl
  93. set Tcl::startPara {^(.*\{)?[ \t]*(#|$)}
  94. set Tcl::endPara {^(.*\})?[ \t]*(#|$)}
  95. set Tcl::commentRegexp {^[ \t]*#}
  96.  
  97. ## 
  98.  # -------------------------------------------------------------------------
  99.  # 
  100.  # "Tcl::_updateKeywords" --
  101.  # 
  102.  #  This proc now includes support for optional separate colorization of 
  103.  #  alpha commands. To use, set 'alphaKeyWordColor' to something other than 
  104.  #  'none' in the Tcl Mode Preferences dialog. -trf
  105.  # -------------------------------------------------------------------------
  106.  ##
  107. proc Tcl::_updateKeywords {args} {
  108.     set tclKeyWords {
  109.     after append array auto_execok auto_load auto_mkindex 
  110.     auto_reset beep binary break case catch cd clock close concat 
  111.     continue echo eof error eval exit expr fblocked fconfigure 
  112.     fcopy file fileevent flush for foreach format gets glob global 
  113.     history if incr info interp join lappend lindex linsert list 
  114.     llength load lrange lreplace ls lsearch lsort namespace open 
  115.     package pid pkg_mkIndex proc puts pwd read regexp regsub 
  116.     rename resource return scan seek set socket source split 
  117.     string subst switch tclMacPkgSearch tclPkgSetup tclPkgUnknown 
  118.     tell time trace unknown unset update uplevel upvar variable 
  119.     vwait while scancontext else elseif default
  120.     }
  121.     
  122.     set alphaKeyWords {
  123.     abortEm abbrev addAlphaChars addMenuItem addDef addArrDef 
  124.     AEBuild alertnote alphaHelp ascii askyesno backColor backSpace 
  125.     backwardChar backwardCharSelect backwardDeleteWord 
  126.     backwardWord balance beginningBufferSelect beginningLineSelect 
  127.     beginningOfBuffer beginningOfLine Bind blink breakIntoLines 
  128.     bringToFront buttonAlert capitalizeRegion capitalizeWord 
  129.     centerRedraw clear closeAll colors colorTriple copy cp 
  130.     createTagFile createTMark currentPosition cut decToHex 
  131.     deleteChar deleteMenuItem deleteModeBindings deleteSelection 
  132.     deleteWord describeBinding deleteText dialog dirs display 
  133.     displayMode dosc downcaseRegion downcaseWord dumpColors 
  134.     dumpMacro edit enableMenuItem endBufferSelect endKeyboardMacro 
  135.     endLineSelect endOfBuffer endOfLine enterSelection evaluate
  136.     eventHandler exchangePointAndMark execAbbrev execute 
  137.     executeKeyboardMacro fileInfo fileRemove find findAgain 
  138.     findAgainBackward findFile findInNextFile findTag float 
  139.     floatShowHide forwardChar forwardCharSelect forwardWord 
  140.     freeMem get_directory getAscii getChar getModifiers getColors 
  141.     getfile getFileInfo getGeometry getline getMainDevice getMark 
  142.     getNamedMarks getPathName getPos getScrap getSelect getText 
  143.     getTMarks getWinInfo goto gotoMark gotoTMark hexToDec icon 
  144.     icURL icGetPref icOpen insertAscii insertColorEscape 
  145.     insertFile insertMenu insertPathName insertText insertToTop 
  146.     isearch iterationCount jumpToRegister keyAscii keyCode 
  147.     killLine killWindow largestPrefix launch lineStart 
  148.     listBindings listpick lookAt markHilite markMenuItem 
  149.     matchBrace matchIt maxPos Menu message mkdir mousePos 
  150.     moveInsertionHere moveFile moveWin mtime nameFromAppl new 
  151.     nextLine nextLineSelect nextLineStart nextSentence nextWindow 
  152.     now oneSpace openLine otherPane pageBack pageForward pageSetup 
  153.     paste pointToRegister popd posToRowCol prefixChar previousLine 
  154.     prevLineSelect prevSentence prevWindow print processes prompt 
  155.     pushd putfile putScrap quit rectMarkHilite redo 
  156.     regModeKeywords removeArrDef removeDef removeFile removeMark 
  157.     removeMenu removeTMark replace replaceAll replace&FindAgain 
  158.     replaceString replaceText restoreVars revert rmdir rowColToPos 
  159.     rsearch save saveAs saveVars scrollDownLine scrollLeftCol 
  160.     scrollRightCol scrollUpLine search searchString select selEnd 
  161.     sendOpenEvent sendToBack setFileInfo setFontsTabs setMark 
  162.     setNamedMark setWinInfo shell shiftLeftRegion shiftRightRegion 
  163.     sizeWin sortMarks spacesToTabs specToPathName splitWindow 
  164.     startEscape startKeyboardMacro statusPrompt substituteVars 
  165.     switchTo tab tabsToSpaces tclFileCompletion tclResult 
  166.     thinkReference ticks toggleScrollbar traceFunc unascii unBind 
  167.     undo unfloat upcaseRegion upcaseWord version watchCursor wc 
  168.     winNames wrap wrapText xtclcmd yank zapInvisibles zoom
  169.     }
  170.     
  171.     set tkKeyWords {
  172.     bind bindtags button canvas checkbutton console destroy entry event focus 
  173.     font frame grab grid image menubutton pack place radiobutton raise 
  174.     scale scrollbar text tk tkwait toplevel winfo wm label listbox
  175.     menu
  176.     }
  177.     
  178.     set itclKeyWords {
  179.     @scope body class code common component configbody constructor define 
  180.     destructor hull 
  181.     import inherit itcl itk itk_component itk_initialize itk_interior 
  182.     itk_option iwidgets keep method private protected 
  183.     public
  184.     }
  185.     global TclmodeVars
  186.     # add Tk keywords
  187.     if {$TclmodeVars(recogniseTk)} {
  188.     set tclKeyWords [concat $tclKeyWords $tkKeyWords]
  189.     }
  190.     # add the [incr tcl] keywords
  191.     if {$TclmodeVars(recogniseItcl)} {
  192.     set tclKeyWords [concat $tclKeyWords $itclKeyWords]
  193.     }
  194.     if {$TclmodeVars(recognisePseudoTcl)} {
  195.     set tclKeyWords [concat $tclKeyWords "lunion lreverse lremove lunique car"]
  196.     }
  197.     # add user extras
  198.     global Tclwords
  199.     if {[info exists Tclwords]} {
  200.     set tclKeyWords [concat $tclKeyWords $Tclwords]
  201.     }
  202.     global Tclcmds
  203.     set Tclcmds { append array catch close concat continue elseif error
  204.     for foreach format lindex llength lrange lreplace lsearch lsort regexp 
  205.     regsub rename return string switch while }
  206.     if {$TclmodeVars(recogniseTk)} {
  207.     append Tclcmds {
  208.         tkButtonDown tkButtonEnter tkButtonInvoke tkButtonLeave 
  209.         tkButtonUp tkCancelRepeat tkCheckRadioInvoke tkDarken 
  210.         tkEntryAutoScan tkEntryBackspace tkEntryButton1 
  211.         tkEntryClosestGap tkEntryInsert tkEntryKeySelect 
  212.         tkEntryMouseSelect tkEntryNextWord tkEntryPaste 
  213.         tkEntryPreviousWord tkEntrySeeInsert tkEntrySetCursor 
  214.         tkEntryTranspose tkEventMotifBindings tkFDGetFileTypes 
  215.         tkFirstMenu tkFocusGroup_BindIn tkFocusGroup_BindOut 
  216.         tkFocusGroup_Create tkFocusGroup_Destroy tkFocusGroup_In 
  217.         tkFocusGroup_Out tkFocusOK tkListboxAutoScan 
  218.         tkListboxBeginExtend tkListboxBeginSelect tkListboxBeginToggle 
  219.         tkListboxCancel tkListboxDataExtend tkListboxExtendUpDown 
  220.         tkListboxMotion tkListboxSelectAll tkListboxUpDown tkMbButtonUp 
  221.         tkMbEnter tkMbLeave tkMbMotion tkMbPost tkMenuButtonDown 
  222.         tkMenuDownArrow tkMenuDup tkMenuEscape tkMenuFind 
  223.         tkMenuFindName tkMenuFirstEntry tkMenuInvoke tkMenuLeave 
  224.         tkMenuLeftArrow tkMenuMotion tkMenuNextEntry tkMenuNextMenu 
  225.         tkMenuRightArrow tkMenuUnpost tkMenuUpArrow tkMessageBox 
  226.         tkPostOverPoint tkRecolorTree tkRestoreOldGrab tkSaveGrabInfo 
  227.         tkScaleActivate tkScaleButton2Down tkScaleButtonDown 
  228.         tkScaleControlPress tkScaleDrag tkScaleEndDrag tkScaleIncrement 
  229.         tkScreenChanged tkScrollButton2Down tkScrollButtonDown 
  230.         tkScrollButtonUp tkScrollByPages tkScrollByUnits tkScrollDrag 
  231.         tkScrollEndDrag tkScrollSelect tkScrollStartDrag tkScrollToPos 
  232.         tkScrollTopBottom tkTabToWindow tkTearOffMenu tkTextAutoScan 
  233.         tkTextButton1 tkTextClosestGap tkTextInsert tkTextKeyExtend 
  234.         tkTextKeySelect tkTextNextPara tkTextNextPos tkTextNextWord 
  235.         tkTextPaste tkTextPrevPara tkTextPrevPos tkTextResetAnchor 
  236.         tkTextScrollPages tkTextSelectTo tkTextSetCursor 
  237.         tkTextTranspose tkTextUpDownLine tkTraverseToMenu 
  238.         tkTraverseWithinMenu tk_bisque tk_chooseColor tk_dialog 
  239.         tk_focusFollowsMouse tk_focusNext tk_focusPrev tk_getOpenFile 
  240.         tk_getSaveFile tk_messageBox tk_optionMenu tk_popup 
  241.         tk_setPalette tk_textCopy tk_textCut tk_textPaste
  242.     }
  243.     }
  244.     
  245.     if {$TclmodeVars(recogniseTk)} {
  246.     regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
  247.       -s $TclmodeVars(stringColor) \
  248.       -k $TclmodeVars(keywordColor) Tcl $tclKeyWords 
  249.     # add this line if we can handle double 'magic chars'
  250.     #-m {tk} 
  251.     } else {
  252.     regModeKeywords -e {#} -c $TclmodeVars(commentColor) \
  253.       -s $TclmodeVars(stringColor) \
  254.       -k $TclmodeVars(keywordColor) Tcl $tclKeyWords 
  255.     }
  256.     if {$TclmodeVars(alphaKeyWordColor) != "none"} {
  257.     regModeKeywords -a -k $TclmodeVars(alphaKeyWordColor) Tcl $alphaKeyWords
  258.     }
  259. }
  260. # call it now
  261. Tcl::_updateKeywords
  262.  
  263. proc Tcl::MenuProc {menu item} {
  264.     switch -glob $item {
  265.     "traceThisProc" {
  266.         procs::traceProc [procs::findEnclosingName [getPos]]
  267.     }
  268.     "reformatProc" {
  269.         procs::reformatEnclosing [getPos]
  270.     }
  271.     "reloadProc" {
  272.         procs::loadEnclosing [getPos]
  273.     }
  274.     "findProcDefinition" {
  275.         procs::findDefinition
  276.     }
  277.     "quickFindProc" {
  278.         # use the status line
  279.         procs::quickFindDefn
  280.     }
  281.     "switch*" {
  282.         set v "[string tolower [string range $item 8 end]]Sig"
  283.         global $v
  284.         app::launchFore [set $v]
  285.     }
  286.     default {
  287.         eval $item
  288.     }
  289.     }
  290. }
  291. namespace eval tcltk {}
  292.  
  293. proc tcltk::menuProc {menu item} {
  294.     switch $item {
  295.     "evaluateRemotely" {
  296.         global evaluateRemotely
  297.         set evaluateRemotely [expr 1 - $evaluateRemotely]
  298.     }
  299.     default {
  300.         global tclshSig
  301.         set cmd [getline "Please enter the script to send to tcl-tk"]
  302.         set res [AEBuild -r -t 30000 '$tclshSig' misc dosc ---- "“$cmd”"]
  303.         alertnote "Result was '$res'"
  304.     }
  305.     }
  306. }
  307.  
  308. proc evaluateRemoteSynchronise {args} {
  309.     global evaluateRemotely tclMenu
  310.     catch {markMenuItem "tcl-tk" evaluateRemotely $evaluateRemotely}
  311.     if $evaluateRemotely {
  312.     if {[info commands notRemoteEvaluate] == ""} {
  313.         rename evaluate notRemoteEvaluate
  314.         ;proc evaluate {} {remoteEvaluate}
  315.     }
  316.     menu::replaceRebuild tclMenu "•320"
  317.     } else {
  318.     if {[info commands notRemoteEvaluate] != ""} {
  319.         rename evaluate {}
  320.         rename notRemoteEvaluate evaluate
  321.     }
  322.     menu::replaceRebuild tclMenu "•269"
  323.     }
  324. }
  325.  
  326. proc remoteEvaluate {} {
  327.     global tclshSig
  328.     app::ensureRunning $tclshSig
  329.     set t [getSelect]
  330.     catch {dosc -c '${tclshSig}' -s $t} r
  331.     message "Remote reply: $r"
  332. }
  333. # ◊◊◊◊ Quick Find Proc… ◊◊◊◊ #
  334.  
  335. proc procs::quickFindDefn {} {
  336.     Tcl::DblClickHelper [prompt::statusLineComplete "proc" procs::complete]
  337. }
  338.  
  339. if {[info tclversion] < 8.0} {
  340.     proc procs::complete {pref} {
  341.     return [info commands ${pref}*]
  342.     }
  343. } else {
  344.     proc procs::complete {pref} {
  345.     if {[regexp {(.*)([^:]+)$} $pref "" start tail]} {
  346.         set cmds [info commands ${pref}*]
  347.         foreach child [namespace children ::$start] {
  348.         if {[string match "::${tail}*" $child]} {
  349.             foreach cmd [info commands ${start}${child}::*] {
  350.             lappend cmds [string trimleft $cmd :]
  351.             }
  352.         }
  353.         }
  354.         return $cmds
  355.     } else {
  356.         return [info commands ${pref}*]
  357.     }
  358.     }
  359. }
  360.  
  361. # ◊◊◊◊ electric behaviour ◊◊◊◊ #
  362. proc Tcl::electricLeft {} {
  363.     if {[literalChar]} { insertText "\{"; return }
  364.     set pat "\}\[ \t\r\n\]*(else(if)?)\[ \t\r\n\]*\$"
  365.     set p [getPos]
  366.     if { [set res [findPatJustBefore "\}" "$pat" $p word]] == "" } { 
  367.     insertText "\{"
  368.     return
  369.     }
  370.     # we have an if/else(if)/else
  371.     switch -- $word {
  372.     "else" {
  373.         replaceText [lindex $res 0] $p "\} $word \{\r"
  374.         bind::IndentLine
  375.     }
  376.     "elseif" {
  377.         replaceText [lindex $res 0] $p "\} $word \{"
  378.     }
  379.     }
  380. }
  381.     
  382. proc Tcl::electricRight {} {
  383.     if {[literalChar]} { insertText "\}"; return }
  384.     set p [getPos]
  385.     if { [regexp "\[^ \t\]" [getText [lineStart $p] $p]] } {
  386.     insertText "\}"
  387.     blink [matchIt "\}" [pos::math $p - 1]]
  388.     return
  389.     }
  390.     set start [lineStart $p]
  391.     insertText "\}"
  392.     createTMark tcl_er [getPos]
  393.     backwardChar
  394.     bind::IndentLine
  395.     gotoTMark tcl_er ; removeTMark tcl_er
  396.     bind::CarriageReturn
  397.     blink [matchIt "\}" [pos::math $start - 1]]
  398. }
  399.  
  400. ## 
  401.  # -------------------------------------------------------------------------
  402.  # 
  403.  # "Tcl::correctIndentation" --
  404.  # 
  405.  #  Returns the correct indentation for the line containing $pos, if that
  406.  #  line were to contain ordinary characters only.  It is the 
  407.  #  responsibility of the calling procedure to ensure that if we are to
  408.  #  insert/have a line already, that that information is taken into
  409.  #  account, by passing in the argument 'next'
  410.  # -------------------------------------------------------------------------
  411.  ##
  412. proc Tcl::correctIndentation {pos {next ""}} {
  413.     global indent_amounts indentSlashEndLines
  414.     # preliminaries
  415.     if {[pos::compare [set beg [lineStart $pos]] == [minPos]]} { return 0 }
  416.     # if the current line is a comment, we have to check some
  417.     # special cases
  418.     if {[set next [string index $next 0]] == "\#"} {
  419.     set p [prevLineStart $beg]
  420.     if {[catch {set p [search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^ \t\r\n\]" \
  421.       [pos::math $beg - 1]]}]} {
  422.         # check for search bug at beginning of file.
  423.         if {[pos::compare $p == [minPos]]} {
  424.         if {[getText [minPos] [pos::math [minPos] + 2]] == "\#\#"} {
  425.             return 1
  426.         }
  427.         }
  428.         return 0
  429.     }
  430.     set prev [pos::math [lindex $p 1] - 1]
  431.     set p [lindex $p 0]
  432.     if {[lookAt $prev] != "\#" || ($beg == [minPos])} {
  433.         # not a comment, so indent with code
  434.     } else {
  435.         set lwhite [posX $prev]
  436.         # it's a comment
  437.         if {[getText $prev [pos::math $prev + 2]] == "\#\#" && \
  438.           [lookAt [pos::math $prev + 2]] != "\#" } {
  439.         
  440.         # it's a comment paragraph
  441.         incr lwhite 
  442.         }
  443.     }
  444.     }
  445.     if {![info exists lwhite]} {
  446.     if ![catch {search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^\# \t\r\n\]" [pos::math $beg - 1]} lst] {
  447.         # Find the last non-comment line and get its leading whitespace    
  448.         set lwhite [posX [pos::math [lindex $lst 1] - 1]]
  449.         set pe1 [lookAt [pos::math $beg - 2]]
  450.         set lst [lindex $lst 0]
  451.         set lastC [lookAt [lindex [search -s -f 0 -r 1 -i 0 -m 0 "\[^ \t\r\n\]" [pos::math [nextLineStart $lst] - 1]] 0]]
  452.         if {$next == "\}"} {
  453.         incr lwhite $indent_amounts(-2)
  454.         set pe2 [lookAt [pos::math [prevLineStart $beg] - 2]]
  455.         if {$pe1 == "\\"} {
  456.             incr lwhite $indent_amounts(1)
  457.         } else {
  458.             if {$pe2 == "\\"} {
  459.             incr lwhite $indent_amounts(-1)
  460.             }
  461.         }
  462.         if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  463.         } else { 
  464.         if {$pe1 == "\\"} {
  465.             if {[lookAt [pos::math [prevLineStart $beg] - 2]] != "\\"} {
  466.             incr lwhite $indent_amounts($indentSlashEndLines)
  467.             }
  468.         } else {
  469.             if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  470.             if {[lookAt [pos::math $lst - 2]] == "\\"} {
  471.             incr lwhite $indent_amounts(-$indentSlashEndLines)
  472.             }
  473.         }
  474.         }
  475.     } else {
  476.         # basically failed in all the above, so keep current indentation
  477.         set lwhite [posX [text::firstNonWsLinePos $beg]]
  478.     }
  479.     }
  480.     return [expr $lwhite > 0 ? $lwhite : 0]
  481. }
  482.  
  483. ## 
  484.  # -------------------------------------------------------------------------
  485.  #   
  486.  # "Tcl::indentLine" --
  487.  #  
  488.  #  Indentation for Tcl mode.  Better and faster than the generic procedure
  489.  # -------------------------------------------------------------------------
  490.  ##
  491. proc Tcl::indentLine {} {
  492.     set beg [lineStart [getPos]]
  493.     set text [getText $beg [nextLineStart $beg]]
  494.     regexp "^\[ \t\]*" $text white
  495.     set next [pos::math $beg + [string length $white]]
  496.     set lwhite [Tcl::correctIndentation [getPos] [lookAt $next]]
  497.     
  498.     set lwhite [text::indentOf $lwhite]
  499.     if {$white != $lwhite} {
  500.     replaceText $beg $next $lwhite
  501.     }
  502.     goto [pos::math $beg + [string length $lwhite]]
  503. }
  504. # ◊◊◊◊ Tcl Menu support ◊◊◊◊ #
  505.  
  506. proc procs::reformatEnclosing {pos} {
  507.     set p [procs::findEnclosing $pos "proc|body|configbody" 1]
  508.     eval select $p
  509.     ::indentRegion
  510. }
  511.  
  512. proc procs::loadEnclosing {pos} {
  513.     if {[catch {procs::findEnclosing $pos "proc|body|configbody" 1} p]} {
  514.     evaluateLine $pos
  515.     } else {
  516.     eval select $p
  517.     uplevel \#0 evaluate    
  518.     }
  519.     goto $pos
  520. }
  521.  
  522. proc procs::findDefinition {} {
  523.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  524.     set func [listpick -L $sel -p {Proc?} [lsort -ignore [info procs]]]
  525.     } else {
  526.     set func [listpick -p {Proc?} [lsort -ignore [info procs]]]
  527.     }
  528.     
  529.     editMark [procs::find $func] $func
  530. }
  531.  
  532. proc insertMenuCodes {} {
  533.     insertText [prompt::getAKey]
  534. }
  535.  
  536. proc insertBindingCodes {} {
  537.     beep
  538.     keyCode
  539. }
  540.  
  541. proc addRemoveDollars {} {
  542.     set p [getPos]
  543.     backwardWord
  544.     if {[lookAt [getPos]] == "\$"} {
  545.     deleteChar
  546.     goto [expr $p -1]
  547.     } else {
  548.     insertText "\$"
  549.     goto [expr $p +1]
  550.     }
  551. }
  552.  
  553. ## 
  554.  # -------------------------------------------------------------------------
  555.  # 
  556.  # "insertDivider" --
  557.  # 
  558.  #  Modified from Vince's original to allow you to just select part of
  559.  #  an already written comment and turn it into a Divider. -trf
  560.  # -------------------------------------------------------------------------
  561.  ##
  562. proc insertDivider {} {
  563.     if {[isSelection]} {
  564.     set enfoldThis [getSelect]
  565.     beginningOfLine
  566.     killLine
  567.     insertText "# ◊◊◊◊ $enfoldThis ◊◊◊◊ #"
  568.     return
  569.     } 
  570.     elec::Insertion "# ◊◊◊◊ •• ◊◊◊◊ #"
  571. }
  572.  
  573. # vince's versions seems to have been left out, so here's mine -trf
  574. # If there is a selection, it get surrounded, if there is no selection,
  575. # but the cursor is touching the end of a word, it gets surrounded. 
  576. # Otherwise, we get a template (could not come up with a "stop beyond")
  577. proc surroundWithBullets {} {
  578.     if {[pos::compare [getPos]==[selEnd]]}    {
  579.     set p [getPos]
  580.     backwardWord 
  581.     set sw [getPos]
  582.     forwardWord 
  583.     set ew [getPos]
  584.     goto $p
  585.     if {[pos::compare $p == $ew]} {
  586.         select $sw $ew
  587.     } 
  588.     }
  589.     if {[isSelection]} {
  590.     set enfoldThis [getSelect]
  591.     deleteSelection
  592.     insertText "•$enfoldThis•"
  593.     return
  594.     } 
  595.     insertText "••"
  596.     backwardChar
  597.     elec::Insertion "•replace-this•"
  598. }
  599. # ◊◊◊◊ Info providers ◊◊◊◊ #
  600. #===============================================================================
  601.  
  602. ## 
  603.  # -------------------------------------------------------------------------
  604.  # 
  605.  # "TclOptionTitlebar" --
  606.  # 
  607.  #  Add corresponding extension/non-extension files.
  608.  # -------------------------------------------------------------------------
  609.  ##
  610. proc Tcl::OptionTitlebar {} {
  611.     if [package::active smarterSource] {
  612.     set n [win::CurrentTail]
  613.     if {[set a [string first + $n]] != -1} {
  614.         return "[string range $n 0 [expr $a -1]][file extension $n]"
  615.     } else {
  616.         global tclExtensionsFolder
  617.         pushd $tclExtensionsFolder
  618.         set f [glob -nocomplain "[file root $n]+*[file extension $n]"]
  619.         popd
  620.         return $f
  621.     }
  622.     } else {
  623.     return ""
  624.     }
  625. }
  626.  
  627. proc Tcl::DblClick {from to shift option control} {
  628.     
  629.     # if cmd and cntrl were pressed, we look to select part of
  630.     # a combination word (less any leading dollar sign) -trf
  631.     if {$control != 0} {
  632.     set clickedPos [getPos]    
  633.     if {[lookAt $from] == "\$"} {
  634.         set from [pos::math $from + 1]
  635.     } 
  636.     set sel_start $clickedPos 
  637.     set    selStartNotDetermined 1
  638.     while {$selStartNotDetermined && ([pos::math $sel_start > $from])} {
  639.         set char [lookAt $sel_start] 
  640.         if {[regexp {_} $char]} {
  641.         set sel_start [pos::math $sel_start + 1]
  642.         set selStartNotDetermined 0
  643.         } elseif {[regexp {[A-Z]} $char]} {
  644.         set selStartNotDetermined 0
  645.         } else {
  646.         set sel_start [pos::math $sel_start -1]
  647.         } 
  648.     }
  649.     set sel_end   $clickedPos 
  650.     set    selEndNotDetermined 1
  651.     while {$selEndNotDetermined && ([pos::math $sel_end <= $to])} {
  652.         set char [lookAt $sel_end] 
  653.         if {[regexp "\[A-Z_ \t\r\]" $char]} {
  654.         set selEndNotDetermined 0
  655.         } else {
  656.         set sel_end [pos::math $sel_end + 1]
  657.         } 
  658.     }
  659.     select $sel_start $sel_end 
  660.     return
  661.     } 
  662.     
  663.     # otherwise, we try to impart some extra info
  664.     select $from $to
  665.     
  666.     if {[catch {Tcl::DblClickHelper [getSelect]}]} {
  667.     message "No docs $shift $control $option"
  668.     }
  669. }
  670.  
  671.  
  672. # Now finds commands in Alpha Commands,
  673. # which has a <cr> immediately after them, e.g. beep, ticks.
  674. proc Tcl::DblClickHelper {text} {
  675.     global HOME auto_index auto_path
  676.     # Is it a loadable proc?
  677.     if {[string length [set f [procs::find $text]]]} {
  678.     if {[editMark $f $text]} {
  679.         # some marking schemes commonly used for Tcl modes
  680.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  681.     }
  682.     return
  683.     }
  684.     
  685.     if {[info exists "auto_index($text)"]} {
  686.     if {[editMark "$auto_index($text)" $text]} {
  687.         # some marking schemes commonly used for Tcl modes
  688.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}" [minPos]] 0]
  689.     }
  690.     return
  691.     }
  692.     # Is it a built-in Alpha command?
  693.     set lines [grep "^• $text\( |$)" [file join $HOME Help "Alpha Commands"]]
  694.     if {[string length $lines]} {
  695.     if {[catch {editMark [file join $HOME Help "Alpha Commands"] $text}]} {
  696.         # mark failed for some reason, but we have the line number
  697.         # anyway.
  698.         file::openQuietly [file join $HOME Help "Alpha Commands"]
  699.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  700.     }
  701.     setWinInfo read-only 1
  702.     return
  703.     }
  704.     # Is it a core Tcl command?
  705.     set lines [grep "^     $text -" [file join $HOME Help "Tcl Commands"]]
  706.     if {[string length $lines]} {
  707.     if {[catch {editMark [file join $HOME Help "Tcl Commands"] $text}]} {
  708.         # mark failed for some reason, but we have the line number
  709.         # anyway.
  710.         file::openQuietly [file join $HOME Help "Tcl Commands"]
  711.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  712.     }
  713.     setWinInfo read-only 1
  714.     return
  715.     }
  716.     # Is it a global variable?
  717.     if {[llength [info globals [string trimleft $text {$}]]]==1} {
  718.     showVarValue [string trimleft $text {$}]
  719.     return
  720.     }
  721.     # (becoming desperate) is it a mark in the current file?
  722.     if {[lsearch [getNamedMarks -n] ${text}] != -1} {
  723.     gotoMark $text
  724.     return
  725.     }
  726.     error ""
  727. }
  728.  
  729. #############################################################################
  730. #  Report the current value of a global variable, chosen interactively
  731. #  from a list of all active variables.
  732. #
  733. #  If the variable is an array, or its value is too big to fit in an 
  734. #  alertnote, then its contents are listed in a new window, otherwise 
  735. #  the variable's value is displayed in an alertnote.
  736. #
  737. proc getVarValue {} {
  738.     set def [getText [getPos] [selEnd]]
  739.     set var [getVarFromList $def]
  740.     if {[string length $var] == 0} return
  741.     showVarValue $var
  742. }
  743.  
  744. if {[info tclversion] < 8.0} {
  745.     
  746. proc getVarFromList {{def ""}} {
  747.     return [listpick -p {Which var?} -L $def [lsort -ignore [info globals]]]
  748. }
  749.     
  750. } else {
  751.     
  752. proc getVarFromList {{def ""}} {
  753.     set ns "[namespace qualifiers $def]"
  754.     set def [namespace tail $def]
  755.     
  756.     set items {}
  757.     foreach var [info vars "${ns}::*"] {
  758.         lappend items [namespace tail $var]
  759.     }
  760.     foreach space [namespace children $ns] {
  761.         lappend items "[namespace tail $space]::"
  762.     }
  763.     
  764.     set items [concat "::" [lsort -ignore $items]]
  765.     set var [listpick -p "Which var in namespace ${ns}::?" -L $def $items]
  766.     if {$var == "::"} {
  767.         set var [getVarFromList $ns]
  768.     } elseif {[namespace qualifiers $var] != ""} {
  769.         set var [getVarFromList "${ns}::${var}"]
  770.     } else {
  771.         set var "${ns}::${var}"
  772.     }
  773.     return $var
  774. }
  775. }
  776.  
  777. #############################################################################
  778. #  Report the current value of a global variable, chosen interactively
  779. #  from a list of all active variables.
  780. #
  781. #  If the variable is an array, or its value is too big to fit in an 
  782. #  alertnote, then its contents are listed in a new window, otherwise 
  783. #  the variable's value is displayed in an alertnote.
  784. #
  785. proc showVarValue {var} {
  786.     global $var
  787.     if {![catch {set $var} value]} {
  788.         viewValue $var $value
  789.     return
  790.     } else {
  791.     regsub -all : $var . var1
  792.         new -n "* $var1 *"
  793.         listArray $var
  794.     }
  795.     # if 'shrinkWindow' is loaded, call it to trim the output window.
  796.     catch {shrinkWindow 2}
  797.     winReadOnly
  798. } 
  799.  
  800. #############################################################################
  801. #  List the name and value of each element of the array $arrName.
  802. #  (Convenient to use as a shell command.)
  803. #
  804. proc listArray {arrName} {
  805.     global $arrName
  806.     set lines {}
  807.     if {![catch {info vars $arrName}]} {
  808.         foreach nm [array names $arrName] {
  809.             # modified to handle odd named arrays -trf
  810.             set val [eval set \{$arrName\($nm\)\}]
  811.             append lines "\r\"$nm\"\t\{$val\}"
  812.         }
  813.         insertText $lines
  814.     } else {
  815.         alertnote "\"$arrName\" doesn't exist in this context"
  816.     }
  817. }
  818.  
  819. # ◊◊◊◊ Marking ◊◊◊◊ #
  820. # note: I put these procs in this order to reflect where you go to activate
  821. #  them, i.e. parseFuncsTcl via 'braces' pop-up, which is on top of the 
  822. # 'M' pop-up (invokes Tcl::MarkFile).
  823.  
  824. ## 
  825.  # -------------------------------------------------------------------------
  826.  #     
  827.  # "Tcl::parseFuncs" --
  828.  #    
  829.  #    This proc is called    by the "braces"    pop-up.    It returns a dynamically
  830.  #    created, alphabetical, list of    "pseudo-marks".
  831.  #    
  832.  #    Author:    Tom    Fetherston
  833.  # -------------------------------------------------------------------------
  834.  ## called by the "{}" button
  835. proc Tcl::parseFuncs {} {
  836.     global TclmodeVars
  837.     set end [maxPos]
  838.     set pos [minPos]
  839.     set l {}
  840.     set markExpr "^\[ \t\]*((itcl(::|_))?class|body|proc|method|body)\[ \t\]"
  841.     set appearanceList {}
  842.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  843.     set start [lindex $res 0]
  844.     set end [nextLineStart $start]
  845.     set t [getText $start $end]
  846.     append t "\}"
  847.     switch [lindex $t 0] {
  848.         "proc" {
  849.         set argLabel {}
  850.         append argLabel [set word [lindex $t 1] ]
  851.         #get the list of arguments
  852.         set argsList [lindex $t 2]
  853.         if {[llength $argsList] > 0} {
  854.             append argLabel " \{"
  855.             foreach arg $argsList {
  856.             if {[llength $arg] == 2 } {
  857.                 append argLabel "¿"
  858.             } elseif {[set arg] != "args"} {
  859.                 append argLabel "•"
  860.             } else {
  861.                 append argLabel "…"
  862.             }
  863.             }
  864.             append argLabel "\}"                    
  865.         } 
  866.         }
  867.     }
  868.     if {[info exists cnts($word)]} {
  869.         # This section handles duplicate. i.e., overloaded names
  870.         set cnts($word) [expr $cnts($word) + 1]
  871.         set tailOfTag($word) " ($cnts($word) of $cnts($word))"
  872.         # we want the tag to point to its last occurence 
  873.         # because in Tcl, that proc will be 'in-force' when the
  874.         # file is loaded.
  875.         set indx($word) [lineStart [pos::math $start - 1]]
  876.     } else {
  877.         #SO do: remember the following
  878.         set cnts($word) 1
  879.         # if this is the only occurence of this proc, remember where it starts
  880.         set indx($word) [lineStart [pos::math $start - 1]]
  881.     }
  882.     #associate name and tag
  883.     set tag($word) $argLabel
  884.     
  885.     #advance pos to where we want to start the next search from
  886.     set pos $end
  887.     }
  888.     
  889.     set rtnRes {}
  890.     
  891.     if {[info exists indx]} {
  892.     foreach hn [lsort -ignore [array names indx]] {
  893.         set next [nextLineStart $indx($hn)]
  894.         set completeTag [set tag($hn)]
  895.         if {[info exists tailOfTag($hn)]} {
  896.         append completeTag [ set tailOfTag($hn) ]
  897.         }
  898.         
  899.         lappend rtnRes $completeTag $next
  900.     }
  901.     }
  902.     return $rtnRes 
  903. }
  904.  
  905. # called by the "M" button
  906. proc Tcl::MarkFile {} {
  907.     global structuralMarks
  908.     set end [maxPos]
  909.     set pos [minPos]
  910.     set l {}
  911.     if $structuralMarks {
  912.     set markExpr {^;?[     ]*((itcl(::|_))?class|namespace eval|proc|method|(config)?body|# ◊◊◊◊)[     ]}
  913.     } else {
  914.     set markExpr {^;?[     ]*((itcl(::|_))?class|namespace eval|proc|method|(config)?body)[     ]}
  915.     }
  916.     set class ""
  917.     set hasMarkers 0
  918.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  919.     set start [lindex $res 0]
  920.     set end [nextLineStart $start]
  921.     set t [string trim [getText $start $end] ";"]
  922.     append t "\}"
  923.     if {[catch {lindex $t 0}]} {
  924.         # wasn't a well formed list
  925.         set pos $end
  926.         continue
  927.     }
  928.     switch -glob [lindex $t 0] {
  929.         "proc" -
  930.         "configbody" { set text [lindex $t 1] }
  931.         "method" { set text ${class}::[lindex $t 1] }
  932.         "body" { 
  933.         regexp {[a-zA-Z_][a-zA-Z_/0-9]*::[a-zA-Z_][a-zA-Z_/0-9]* } \
  934.           "[lindex $t 1] " text
  935.         }
  936.         "namespace" {
  937.         set ns [lindex $t 2]
  938.         set text "${ns} 111" 
  939.         }
  940.         "*class" { 
  941.         set class [lindex $t 1]
  942.         set text "${class} 000" 
  943.         }
  944.         "#" { 
  945.         regexp "# ◊◊◊◊ (.*) ◊◊◊◊" $t all text
  946.         if {[regexp "^(    )|(    )# ◊◊◊◊ " $t]} {
  947.             set text " •$text"
  948.         } else {
  949.             set text "•$text"
  950.         }                 
  951.         set hasMarkers 1
  952.         }
  953.     }
  954.     set pos $end
  955.     if {$structuralMarks} {
  956.         lappend asEncountered $text
  957.         set arr inds
  958.     } else {
  959.         if {[string index $t 0] == ";"} {
  960.         set arr iinds
  961.         } else {
  962.         set arr inds
  963.         }
  964.     }
  965.     set ${arr}($text) [lineStart [pos::math $start - 1]]
  966.     }
  967.     
  968.     set already ""
  969.     set class "#"
  970.     foreach arr {inds iinds} {
  971.     if {[info exists $arr]} {
  972.         if {$arr == "iinds"} {
  973.         setNamedMark "-" 0 0 0
  974.         }
  975.         if $structuralMarks {
  976.         set order $asEncountered
  977.         } else {
  978.         set order [lsort -ignore [array names $arr]]
  979.         }
  980.         foreach f $order {
  981.         if {[set el [set ${arr}($f)]] != 0} {
  982.             set next [nextLineStart $el]
  983.         } else {
  984.             set next 0
  985.         } 
  986.         
  987.         if { [string first "000" $f] != -1 } {
  988.             set ff "Class '[set class [lindex $f 0]]'"
  989.         } elseif { [string first "111" $f] != -1 } {
  990.             set ff "Namespace '[set class [lindex $f 0]]'"
  991.         } elseif { [string first "${class}::" $f] != -1 } {
  992.             set ff [string range $f [string length $class] end]
  993.         } else {
  994.             set ff $f
  995.         }
  996.         while { [lsearch -exact $already $ff] != -1 } {
  997.             set ff "$ff "
  998.         }
  999.         lappend already $ff
  1000.         if {$hasMarkers && ![string match "•*" $ff] } {
  1001.             set ff " $ff"
  1002.         } 
  1003.         setNamedMark $ff $el $next $next
  1004.         }
  1005.     }
  1006.     }
  1007. }
  1008.  
  1009. # ◊◊◊◊ Misc. ◊◊◊◊ #
  1010.  
  1011. ## 
  1012.  # -------------------------------------------------------------------------
  1013.  # 
  1014.  # "bind::tclContinueComment" --
  1015.  # 
  1016.  #  exploits a "feature" in the code that makes a new line a comment whenever 
  1017.  #  you are 'inside' a comment. This proc puts a pound sign at the end of the 
  1018.  #  current line, backsteps, and creates a new line. With the pound sign 
  1019.  #  present you are considered to be in a comment, so the bind::CarriageReturn 
  1020.  #  in the proc, and any subsequent bind::CarriageReturn called by a press of  
  1021.  #  the return key will provide another comment line automatically until the 
  1022.  #  pound sign at the end of the line is removed (killLine is handy for this).
  1023.  # -------------------------------------------------------------------------
  1024.  ##
  1025. proc bind::tclContinueComment {} {
  1026.     insertText {#}
  1027.     backwardChar
  1028.     bind::CarriageReturn
  1029. }
  1030. Bind '\r' <c> bind::tclContinueComment Tcl
  1031.  
  1032. proc evaluateLine { pos } {
  1033.     goto $pos
  1034.     beginningLineSelect
  1035.     endLineSelect
  1036.  
  1037.     uplevel \#0 evaluate
  1038.  
  1039. }
  1040.  
  1041.  
  1042.  
  1043. #◊◊◊◊> 
  1044.  
  1045.  
  1046.  
  1047. evaluateRemoteSynchronise
  1048.  
  1049.